Software Vault: The Diamond Collection/The Diamond Collection (Software Vault)(Digital Impact).ISO/cdr43/ppl4p10.zip/SI.PAS

Pascal/Delphi Source File | 1995-02-20 | 13KB | 634 lines

(*
**
**   --- please read this ! ---
**
**  This source code is in "shrouded" form. It is distributed in this form
**  rather than as a library (.LIB) file because of the inconsistancies
**  between object files generated by different compilers. To support several
**  compilers would require a .LIB file for each compiler manufacturer, and
**  sometimes several versions of the .LIB file are needed for the different
**  versions of the same manufacturers compiler!
**
**  You can compile this code, but you will have to register with us in order
**  to get the normal (commented) C source code with normal variable names.
*)







{$I DEFINES.PAS}

unit SI;

interface

const
  SI_CANNOT_OPEN          = -101;
  SI_UNEXPECTED_EOF       = -102;
  SI_NOT_SCRIPT_BINARY    = -103;
  SI_NOT_CURRENT_VERSION  = -104;
  SI_CODE_LENGTH_OVERFLOW = -105;
  SI_DATA_LENGTH_OVERFLOW = -106;
  SI_BAD_OPCODE           = -107;
  SI_USER_ABORTS          = -108;
  SI_STACK_OVERFLOW       = -109;
  SI_STACK_UNDERFLOW      = -110;
  SI_BAD_CHECKSUM         = -111;

procedure SaySiErr(V6:Integer);
function  Script(Port:Integer;Filename:String;Debug:Boolean):Integer;

implementation

uses CRT, PCL4P, MODEM_IO, FILE_IO, OPCODES, TERM_IO, XYMODEM, XYPACKET, ZMODEM;

const
   BUFFER_SIZE = 128;
   CODE_SIZE   = 256;
   DATA_SIZE   = 1024;
   STACK_SIZE  = 32;
   V55     = 2;

var
   Filename  : String;
   V23    : File;
   V26      : Integer;
   V46     : Integer;
   V48  : Integer;
   V5  : Byte;
   V10    : Integer;
   V16    : Integer;
   V34   : Char;
   V35  : Integer;
   V38   : Integer;
   V36   : Integer;
   V33   : Boolean;
   V37: Char;
   V2  : Integer;
   V32: Integer;
   V13  : Integer;
   V49  : Integer;
   V28   : Byte;
   V29  : Boolean;
   V7  : array[0..CODE_SIZE-1] of Byte;
   V12  : array[0..DATA_SIZE-1] of Byte;
   V4    : array[0..BUFFER_SIZE-1] of Byte;
   V47 : array[0..STACK_SIZE-1] of Byte;

procedure SaySiErr(V6:Integer);
begin
  case V6 of
    SI_CANNOT_OPEN:    WriteLn('Cannot open script binary');
    SI_UNEXPECTED_EOF: WriteLn('Unexpected EOF');
    SI_NOT_SCRIPT_BINARY:   WriteLn('Not script binary');
    SI_NOT_CURRENT_VERSION: WriteLn('Incorrect script version');
    SI_CODE_LENGTH_OVERFLOW:WriteLn('Code Overflow');
    SI_DATA_LENGTH_OVERFLOW:WriteLn('Data Overflow');
    SI_BAD_OPCODE:     WriteLn('Bad opcode encountered');
    SI_USER_ABORTS:    WriteLn('User aborting...');
    SI_STACK_OVERFLOW: WriteLn('Stack overflow');
    SI_STACK_UNDERFLOW:WriteLn('Stack underflow');
    SI_BAD_CHECKSUM:   WriteLn('Bad checksum');
  else
    WriteLn('Script Error ',V6);
  end;
end;


function V22:Integer;
var
  V54 : Byte;
begin
  if V26=V46 then
  begin

    V26 := 0;
    BlockRead(V23,V4,BUFFER_SIZE,V46);
    if V46 <= 0 then
    begin
      V22 := -1;
      exit;
    end;
  end;

  V54 := V4[V26];
  V26 := V26 + 1;
  V5 := V5 XOR V54;
  V22 := V54;
end;

function V41(Item:Integer):Integer;
begin
  if V48 = STACK_SIZE then V41 := SI_UNEXPECTED_EOF
  else
    begin
      V47[V48] := Item;
      V48 := V48 + 1;
      V41 := 0
    end;
end;

function V39:Integer;
begin
  if V48=0 then V39 := SI_STACK_UNDERFLOW
  else
    begin
      V48 := V48 - 1;
      V39 := V47[V48]
    end
end;

function V21(V17:Integer) : Integer;
const
   V18 : array[1..10] of Integer =
       ($180,$0C0,$060,$030,$018,$00C,$006,$003,$002,$001);
var
   i : Integer;
begin
   for i := 1 to 10 do if V18[i] = V17 then
   begin
     V21 := i - 1;
     exit
   end;

   V21 := -1;
end;

function V45(V20:Boolean):Char;
begin
  if V20 then V45 := 'T'
  else V45 := 'F';
end;

function FetchText(V1:Integer):String;
var
  b : Byte;
  s : String;
  i : Integer;
begin
  s := '';
  for i := 0 to 49 do
  begin
    b := V12[V1+i];
    if b = 0 then
    begin
      FetchText := s;
      exit;
    end;
    s := s + chr(b);
  end
end;

function FetchReal(V1:Integer):Real;
var
  V6    : Integer;
  V53    : String;
  V44 : Real;
begin
  V53 := FetchText(V1);
  Val(V53,V44,V6);
  FetchReal := V44;
end;

function FetchInteger(V1:Integer):Integer;
var
  V6  : Integer;
  V53  : String;
  V25 : Integer;
begin
  V53 := FetchText(V1);
{$R-}
  Val(V53,V25,V6);
{$R+}
  FetchInteger := V25;
end;



function  Script(Port:Integer;Filename:String;Debug:Boolean):Integer;
var
   i, k      : Integer;
   c         : Char;
   V54   : Byte;
   V20      : Boolean;
   V6      : Integer;
   V30    : Integer;
   V31      : Integer;
   V1      : Integer;
   V8   : Integer;
   V14   : Integer;
   V11: Integer;
   V40       : Integer;
   V24     : Integer;
   Len       : Integer;
   V53      : String;
   V17   : Integer;
   RealValue : Real;
   IntegerValue:Integer;
   Streaming : Boolean;
begin

  V28 := Ord('C');
  V29 := True;
  V48 := 0;
  V5 := 0;
  V10 := 0;
  V16 := 0;
  V34 := chr($ff);
  V35 := 1;
  V36 := 5;
  V33 := True;
  V37 := 'X';
  V38 := 18*30;
  for i := 0 to CODE_SIZE-1 do V7[i] := 0;
  for i := 0 to DATA_SIZE-1 do V12[i] := 0;

  V17 := SioGetDiv(Port);
  V2 := V21(V17);
  if V2 <= Baud19200 then Streaming := False
  else Streaming := True;
  V40 := SioRead(Port,3);
  V13 := $03 AND V40;
  V49 := $01 AND (V40 SHR 2);
  V32 := $07 AND (V40 SHR 3);

{$I-}
  Assign(V23,Filename+'.sb');
  Reset(V23,1);
{$I+}
  if IOResult <> 0 then
  begin
    WriteLn('Cannot open ',Filename);
    exit;
  end;
  V26 := 0;
  V46 := 0;

  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  if V6 <> $55 then
  begin
    Script := SI_NOT_SCRIPT_BINARY;
    exit;
  end;

  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  if V6 <> V55 then
  begin
    Script := SI_NOT_CURRENT_VERSION;
    exit;
  end;

  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  V8 := $FF AND V6;
  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  V8 := 256 * V8 + ($FF AND V6);
  if V8 > CODE_SIZE then
  begin
    Script := SI_CODE_LENGTH_OVERFLOW;
    exit;
  end;

  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  V14 := $FF AND V6;
  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  V14 := 256 * V14 + ($FF AND V6);
  if V14 > DATA_SIZE then
  begin
    Script := SI_DATA_LENGTH_OVERFLOW;
    exit;
  end;

  for i := 0 to V8-1 do
  begin
    V6 := V22;
    if V6 < 0 then
    begin
      Script := V6;
      exit;
    end;
    V7[i] := V6;
  end;

  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  if V6 <> $55 then
  begin
    Script := SI_NOT_SCRIPT_BINARY;
    exit;
  end;

  for i := 0 to V14-1 do
  begin
    V6 := V22;
    if V6 < 0 then
    begin
      Script := V6;
      exit;
    end;
    V12[i] := V6;
  end;

  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  if V6 <> $55 then
  begin
    Script := SI_NOT_SCRIPT_BINARY;
    exit;
  end;

  V11 := V5;
  V6 := V22;
  if V6 < 0 then
  begin
    Script := V6;
    exit;
  end;
  if V6 <> V11 then
  begin
    Script := SI_BAD_CHECKSUM;
    exit;
  end;

  V6 := SioRxFlush(Port);
  V6 := SioTxFlush(Port);
  V10 := 0;
  repeat

    if SioBrkKey OR KeyPressed then
    begin
      Write('Aborted by user...');
      V6 := SioDone(Port);
      exit;
    end;

    V54 := V7[V10];
    V30 := $003F AND V54;
    V31 := ($00C0 AND V54) SHL 2;
    if Debug then
    begin
      V24 := MatchOpCode(V30);
      if WhereX > 1 then WriteLn;
      Write('@',V10,'  ');
      Write(GetOpText(V24),' ');
    end;
    V10 := V10 + 1;

    if V30 >= 8 then
    begin
      V1 := V31 OR ($00FF AND V7[V10]);
      V10 := V10 + 1;
      if Debug then
      begin
        case GetOperType(V24) of
          CODE_REF: WriteLn(V1);
          DATA_REF:
            begin
              Write('"');
              i := 0;
              Repeat
                k := V12[V1+i];
                i := i + 1;
                if k <> 0 then Write(chr(k));
              until k = 0;
              Writeln('"');
            end
        end
      end
    end;

    case V30 of
      OPC_HALT:
        begin
          Script := 0;
          exit
        end;
      OPC_STATUS:
        begin
          Write('CodePC=',V10,' V30=',V30,' V1=',V1);
          Write(' PSC=',V34,' Count=',V35);
          WriteLn(' Wait=',V38,' V37=',V37);
        end;
      OPC_DELAY:
        begin
          IntegerValue := Round(18.2*FetchReal(V1));
          SioDelay( IntegerValue );
        end;
      OPC_CALL:
        begin
          V6 := V41(V10);
          if V6 < 0 then
            begin
              Script := V6;
              exit;
            end;
          V10 := V1;
        end;
      OPC_RETURN:
        begin
          V6 := V39;
          if V6 < 0 then
            begin
              Script := V6;
              exit;
            end;
          V10 := V6;
        end;
      OPC_BAUD:
        begin
          V53 := FetchText(V1);
          i := MatchBaud(V53);
        end;
      OPC_DATABITS:
        begin
          i := FetchInteger(V1);
          case i of
            7: V13 := WordLength7;
            8: V13 := WordLength8;
          end;
          V6 := SioParms(Port,V32,V49,V13);
        end;
      OPC_STOPBITS:
        begin
          i := FetchInteger(V1);
          case i of
            1: V49 := OneStopBit;
            2: V49 := TwoStopBits;
          end;
          V6 := SioParms(Port,V32,V49,V13);
        end;
      OPC_PARITY:
        begin
          V53 := FetchText(V1);
          case UpCase(V53[1]) of
            'N': V32 := NoParity;
            'O': V32 := OddParity;
            'E': V32 := EvenParity;
          end;
          V6 := SioParms(Port,V32,V49,V13);
        end;
      OPC_REPLY:
        begin
          V53 := FetchText(V1);
          if ModemSendTo(Port,V36,V53) then V34 := chr($ff)
          else V34 := chr($00);
        end;
      OPC_SETCOUNT:
        V35 := FetchInteger(V1);
      OPC_SETWAIT:
        begin
          IntegerValue := Round(18.2*FetchReal(V1));
          V38 := IntegerValue;
        end;
      OPC_LOOP:
        begin
          V35 := V35 - 1;
          if V35 > 0 then V10 := V1
        end;
      OPC_IFTRUE:
        if V34 <> chr($00) then V10 := V1;
      OPC_IFFALSE:
        if V34 = chr($00) then V10 := V1;
      OPC_IF:
        if V34 <> chr(V12[V1]) then V10 := V10 + 2;
      OPC_IFNOT:
        if V34 = chr(V12[V1]) then V10 := V10 + 2;
      OPC_TEST:
        V34 := chr(V12[V1]);
      OPC_ACCEPT:
        begin
          ReadMsg(V53,61,15);
          Len := Length(V53);
          for i := 0 to Len-1 do V12[V1+i] := Byte(V53[i+1]);
          V12[V1+Len] := $00;
        end;
      OPC_GOTO:
        V10 := V1;
      OPC_SAY:
        begin
          V53 := FetchText(V1);
          i := 1;
          while i <= Length(V53) do
            begin
              c := V53[i];
              i := i + 1;
              if c = '^' then
                begin
                  c := chr( Byte(V53[i]) - $40);
                  i := i + 1;
                end;
              Write(c);
            end;
          WriteLn;
        end;
      OPC_WAITFOR:
        begin
          V53 := FetchText(V1);
          V34 := ModemWaitFor(Port,V38,V33,V53);
        end;
      OPC_NOP:
        begin
        end;
      OPC_SETPACE:
        V36 := Round(18.2*FetchReal(V1));
      OPC_SETCASE:
        begin
          V53 := FetchText(V1);
          case UpCase(V53[1]) of
            'T': V33 := True;
            'F': V33 := False;
          end;
        end;
      OPC_QUIET:
        begin
          IntegerValue := Round(18.2*FetchReal(V1));
          ModemQuiet(Port, IntegerValue);
        end;
      OPC_HANGUP:
        ModemHangup(Port);
      OPC_PROTOCOL:
        begin
          V53 := FetchText(V1);
          case UpCase(V53[1]) of
            'X': V37 := 'X';
            'Y': V37 := 'Y';
            'Z': V37 := 'Z';
          end;
        end;
      OPC_SEND:
        begin
          ModemEcho(Port,10);
          V53 := FetchText(V1);
          case V37 of
            'X': V20 := XmodemTx(Port,V53,V29);
            'Y': V20 := YmodemTx(Port,V53,V29);
            'Z': V20 := ZmodemTx(Port,V53,Streaming)
          end;
        end;
      OPC_RECEIVE:
        begin
          ModemEcho(Port,10);
          case V37 of
            'X':
              begin
                V53 := FetchText(V1);
                V20 := XmodemRx(Port,V53,V28)
              end;
            'Y':
              begin
                V53 := '';
                V20 := YmodemRx(Port,V53,V28)
              end;
            'Z':
              begin
                V53 := '';
                V20 := ZmodemRx(Port,V53,Streaming)
              end
            end
        end;
    end;
 until False
end;

end.